home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / analyze.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  11.6 KB  |  317 lines
  1. (herald (front_end analyze)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Checking for user errors and gathering information...
  28.  
  29. ;;; Needs to deal with object nodes
  30.  
  31. (lset *definitions* '())
  32. (lset *uses* '())
  33.  
  34. ;;; Return lists of variable definitions and uses.
  35. ;;;   *DEFINITIONS* is a list of the variables defined in the given node tree.
  36. ;;;   *USES* is a list of uses in the following form:
  37. ;;;     (<variable> <location> <use>)
  38. ;;;   <location> is either 'TOP or the variable whose value contains the use.
  39. ;;;   <use> is one of 'CALL-ARG 'OPERATION, '(CALL . <number of arguments>),
  40. ;;;     or 'WEIRD.
  41.  
  42. (define (def-and-use-analyze node)
  43.   (set *definitions* '())
  44.   (set *uses* '())
  45.   (check-call-node (lambda-body node))
  46.   (return *definitions*
  47.           (map! (lambda (u)
  48.                   (cons *current-module-exp* u))
  49.                 *uses*)))
  50.  
  51. ;;; Check a value node - look at the body of lambdas and the definitions of
  52. ;;; variables.     
  53.  
  54. (define (check-value-node node)
  55.   (cond ((lambda-node? node)
  56.          (check-call-node (lambda-body node)))
  57.         ((object-node? node)
  58.          (check-value-list (object-operations node))
  59.          (check-value-list (object-methods node))
  60.          (check-value-node (object-proc node)))
  61.         ((and (reference-node? node)
  62.               (variable-definition (reference-variable node)))
  63.          => (lambda (def)
  64.               (if (local-definition? def)
  65.                   (push *uses*
  66.                         `(,(reference-variable node) ,(node-use node))))))))
  67.  
  68. (define (check-value-list list)
  69.   (walk (lambda (node)
  70.           (if node
  71.               (check-value-node node)))
  72.         list))
  73.  
  74. ;;; Check calls.  Checks the procedure and then dispatches on the type of
  75. ;;; the call.
  76.  
  77. (define (check-call-node call)
  78.   (cond ((variable-definition? call)
  79.          (check-value-node ((call-arg '1) call))
  80.          (check-value-node ((call-arg '3) call)) 
  81.          (add-definition-value call))
  82.         ((primop-ref? (call-proc call) primop/y)
  83.          (check-y ((call-arg '2) call))
  84.          (check-value-node ((call-arg '1) call)))
  85.         ((lambda-node? (call-proc call))
  86.          (set-check-flags (lambda-variables (call-proc call)) (call-args call))
  87.          (check-value-list (call-proc+args call))
  88.          (reset-check-flags (lambda-variables (call-proc call)))
  89.          (check-call-using-proc call))
  90.         (else
  91.          (check-value-list (call-proc+args call))
  92.          (check-call-using-proc call))))
  93.  
  94. ;;; Does CALL define a variable.
  95.  
  96. (define (variable-definition? call)
  97.   (let ((primop (known-primop (call-proc call))))
  98.     (and primop
  99.          (primop.definition? primop)
  100.          (neq? (primop.definition-variant primop) 'set)
  101.          (fx= '3 (length (call-args call)))
  102.          (reference-node? ((call-arg '2) call))
  103.          (variable-definition (reference-variable ((call-arg '2) call))))))
  104.  
  105. ;;; Set the definition value and type of a variable.
  106.  
  107. (define (add-definition-value call)
  108.   (destructure (((proc cont ref val) (call-proc+args call)))
  109.     (ignore proc)
  110.     (let* ((var (reference-variable ref))
  111.            (def (variable-definition var))
  112.            (variant (definition-variant def)))
  113.       (ignore cont)   
  114.       (if (and (not (memq? var *definitions*))
  115.                (neq? variant 'set))
  116.           (push *definitions* var))
  117.       (real-add-definition-value var val))))
  118.  
  119. (define (real-add-definition-value var val)
  120.   (let ((def (variable-definition var)))
  121.     (cond ((and (or (eq? (definition-variant def) 'define)
  122.                     (eq? (definition-variant def) 'constant))
  123.                 (not (definition->primop def)))
  124.            (if (eq? (definition-variant def) 'constant)
  125.                (set (definition-value def) (node->vector val)))
  126.            (set (definition-type def)
  127.                 (get-node-definition-type val))
  128.            t)
  129.           (else nil))))
  130.  
  131. ;;; Type check of a call using the type of the procedure.
  132.  
  133. (define (check-call-using-proc node)
  134.   (let ((proc (call-proc node)))
  135.     (cond ((literal-node? proc)
  136.            (fix-call-to-literal node (literal-value proc)))
  137.           ((reference-node? proc)
  138.            (check-call-to-var node (reference-variable proc)))
  139.           ((and (lambda-node? proc)      
  140.                 (not (arg-check-of-lambda proc node)))
  141.            (fix-call-to-lambda node proc)))))
  142.  
  143. ;;; Special procedure for checking calls to Y.
  144.  
  145. (define (check-y l-node)
  146.   (let ((vals (cdr (call-args (lambda-body l-node)))))
  147.     (set-check-flags (cdr (lambda-variables l-node))
  148.                      (map thunk-value vals))
  149.     (check-value-node ((call-arg '1) (lambda-body l-node)))
  150.     (check-value-list vals)
  151.     (reset-check-flags (lambda-variables l-node))))
  152.  
  153. ;;; Variables that have known values keep those values in the VARIABLE-FLAG
  154. ;;; field for the purposes of type checking.
  155.  
  156. (define (clear-check-flags node)
  157.   (if (lambda-node? (call-proc node))
  158.       (reset-check-flags (lambda-variables (call-proc node)))))
  159.  
  160. (define (set-check-flags vars args)
  161.   (walk (lambda (var val)
  162.           (if (and var val (lambda-node? val))
  163.               (set (variable-flag var) val)))
  164.         vars
  165.         args))
  166.  
  167. (define (reset-check-flags vars)
  168.   (walk (lambda (var)
  169.           (if var (set (variable-flag var) nil)))
  170.         vars))
  171.  
  172. ;;; Checking a call to a known variables
  173.  
  174. (define (check-call-to-var call var)
  175.   (cond ((variable-binder var)
  176.          (check-call-to-lexical-var call var))
  177.         ((get-variable-definition var)
  178.          => (lambda (def)
  179.               (if (not (local-definition? def))
  180.                   (check-call-to-bound-var call def))))))
  181.  
  182. (define (check-call-to-lexical-var call var)
  183.   (let ((type (variable-flag var)))
  184.     (cond ((and (node? type)
  185.                 (lambda-node? type)
  186.                 (not (arg-check-of-lambda type call)))
  187.            (fix-call-to-bound-lambda call var type)))))
  188.  
  189. (define (check-call-to-bound-var call def)
  190.   (let ((type (definition-type def)))
  191.     (cond ((eq? type 'literal)
  192.            (fix-call-to-early-bound-literal (call-proc call))
  193.            (replace-with-free-variable (call-proc call)))
  194.           ((and (pair? type)
  195.                 (eq? (car type) 'proc)
  196.                 (not (arg-check-of-type type call)))
  197.            (fix-call-to-early-bound-proc (call-proc call))))))
  198.  
  199. (define (arg-check-of-lambda proc node)
  200.   (let ((left-over (fx- (length (call-args node))
  201.                         (length (lambda-variables proc)))))
  202.     (or (fx= left-over '0)
  203.         (and (fx> left-over '0)
  204.              (lambda-rest-var proc)))))
  205.     
  206. (define (arg-check-of-type type node)
  207.   (cond ((eq? type 'object)
  208.          t)
  209.         (else
  210.          (let ((left-over (fx- (length (call-args node))
  211.                                        (caddr type))))
  212.            (or (fx= left-over '0)
  213.                (and (fx> left-over '0)
  214.                     (cadr type)))))))
  215.  
  216. ;;; Is TYPE okay if we ignore the continuation
  217.  
  218. (define (arg-check-of-return-type type node)
  219.   (cond ((eq? type 'object)
  220.          t)
  221.         (else
  222.          (let ((left-over (fx- (fx- (length (call-args node)) 1)
  223.                                (caddr type))))
  224.            (or (fx= left-over '0)
  225.                (and (fx> left-over '0)
  226.                     (cadr type)))))))
  227.  
  228. ;;; The way in which a node is used.  Returns one of (CALL . <# of arguments>),
  229. ;;; OPERATION, CALL-ARG, or WEIRD.
  230.  
  231. (define (node-use node)
  232.   (let ((role (node-role node)))
  233.     (cond ((eq? role call-proc)
  234.            `(call . ,(length (call-args (node-parent node)))))
  235.           ((object-op? role) 'operation)
  236.           ((call-arg? node) 'call-arg)
  237.           (else 'weird))))
  238.  
  239. (define (use-type use)
  240.   (definition-type (variable-definition (cadr use))))
  241.  
  242. (define (check-uses new-uses old-uses)
  243.   (iterate loop ((uses (append new-uses old-uses))
  244.                  (left '()))
  245.     (cond ((null? uses)
  246.            left)
  247.           ((use-type (car uses))
  248.            => (lambda (type)
  249.                 (check-variable-use (car uses) type)
  250.                 (loop (cdr uses) left)))
  251.           (else
  252.            (loop (cdr uses) (cons (car uses) left))))))
  253.  
  254. (define (check-variable-use use var-type)
  255.   (destructure (((loc var use-type) use))
  256.     (cond ((or (not var-type)
  257.                (eq? use-type 'call-arg)
  258.                (eq? use-type 'weird))
  259.            t)
  260.           ((eq? use-type 'operation)
  261.            t)  ; Operations are not annotated yet
  262.           ((or (not (pair? use-type))
  263.                (neq? 'call (car use-type)))
  264.            (bug '"unknown use-type ~S in CHECK-VARIABLE-USE" use-type))
  265.           ((eq? var-type 'literal)
  266.            (user-message-with-location 'warning
  267.                                        loc
  268.                                        '"call to ~S which is bound to a literal" 
  269.                                        nil
  270.                                        (variable-name var)))
  271.           ((and (pair? var-type)
  272.                 (eq? (car var-type) 'proc))
  273.            (if (not (arg-check-of-use var-type use-type))
  274.                (user-message-with-location
  275.                 'warning
  276.                 loc
  277.                 '"wrong number of arguments in a call to ~A"
  278.                 nil
  279.                 (variable-name var)))))))
  280.  
  281. (define (arg-check-of-use var-type use-type)
  282.   (let ((left-over (fx- (cdr use-type)
  283.                         (caddr var-type))))
  284.     (or (fx= left-over '0)
  285.         (and (fx> left-over '0)
  286.              (cadr var-type)))))
  287.  
  288. ;;; Quick version of the above.  Just finds defs and uses.  This is used on
  289. ;;; integrable definitions before they are simplified.
  290.  
  291. (define (quick-def-and-use-analyze node)
  292.   (let ((uses '()) (defs '()))
  293.     (iterate tree-walk ((node node))
  294.       (cond ((lambda-node? node)
  295.              (let ((call (lambda-body node)))
  296.                (if (variable-definition? call)
  297.                    (let ((var (reference-variable ((call-arg '2) call))))
  298.                      (push defs var)))
  299.                (walk tree-walk (call-proc+args call))))
  300.             ((object-node? node)
  301.              (tree-walk (object-proc node))
  302.              (walk tree-walk (object-methods node)))
  303.             ((and (reference-node? node)
  304.                   (variable-definition (reference-variable node)))
  305.              => (lambda (def)
  306.                   (let ((var (reference-variable node)))
  307.                     (if (and (local-definition? def)
  308.                              (not (memq? var uses)))
  309.                         (push uses var)))))))
  310.     (return defs uses)))
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.